home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / games / tetris.el.z / tetris.el
Encoding:
Text File  |  1998-05-21  |  23.2 KB  |  841 lines
  1. ;;; tetris.el -- Implementation of Tetris for Emacs.
  2.  
  3. ;; Copyright (C) 1997 Glynn Clements <glynn@sensei.co.uk>
  4.  
  5. ;; Author: Glynn Clements <glynn@sensei.co.uk>
  6. ;; Version: 1.8
  7. ;; Created: 1997-08-13
  8. ;; Keywords: games
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2 of the License, or
  15. ;; (at your option) any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25. ;; 02111-1307, USA.
  26.  
  27. ;;; Synched up with: Not synched.
  28.  
  29. ;;; Commentary:
  30.  
  31. ;; Modified: 1997-08-17, added tetris-move-bottom
  32. ;; Modified: 1997-08-22, changed setting of display table for compatibility
  33. ;;    with XEmacs 19.15
  34. ;; Modified: 1997-08-23, changed setting of display table for TTY compatibility
  35. ;; Modified: 1997-08-24, various changes for FSF Emacs compatibility
  36. ;; Modified: 1997-08-25
  37. ;;    modified existing docstrings, added new docstrings
  38. ;;    L now rotates the same way as T and mirror-L
  39. ;;    now adds tetris-end-game to buffer-local value of kill-buffer-hook
  40. ;; Modified: 1997-08-26, miscellaneous bugfixes
  41. ;; Modified: 1997-08-27
  42. ;;    added color support for non-glyph mode
  43. ;;    added tetris-mode-hook
  44. ;;    added tetris-update-speed-function
  45. ;; Modified: 1997-09-09, changed layout to work in a 22 line window
  46. ;; Modified: 1997-09-12
  47. ;;    fixed tetris-shift-down to deal with multiple rows correctly
  48. ;; Modified: 1997-09-14, added tetris-setup-default-face
  49. ;; URL: ftp://sensei.co.uk/misc/tetris.el.gz
  50. ;; Tested with XEmacs 20.3-beta and Emacs 19.34
  51. ;; Reported to work with XEmacs 19.15 and 20.2
  52.  
  53. (eval-when-compile
  54.   (require 'cl))
  55.  
  56. ;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57.  
  58. (defvar tetris-use-glyphs t
  59.   "Non-nil means use glyphs when available")
  60.  
  61. (defvar tetris-use-color t
  62.   "Non-nil means use color when available")
  63.  
  64. (defvar tetris-draw-border-with-glyphs t
  65.   "Non-nil means draw a border even when using glyphs")
  66.  
  67. (defvar tetris-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
  68.   "Name of the font used for tetris in X mode")
  69.  
  70. (defvar tetris-default-tick-period 0.3
  71.   "The default time taken for a shape to drop one row")
  72.  
  73. (defvar tetris-update-speed-function
  74.   'tetris-default-update-speed-function
  75.   "Function run whenever the Tetris score changes
  76. Called with two arguments: (SHAPES ROWS)
  77. SHAPES is the number of shapes which have been dropped
  78. ROWS is the number of rows which have been completed
  79.  
  80. If the return value is a number, it is used as the timer period")
  81.  
  82. (defvar tetris-mode-hook nil
  83.   "Hook run upon starting Tetris")
  84.  
  85. ;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86.  
  87. (defconst tetris-buffer-name "*Tetris*"
  88.   "Name used for Tetris buffer")
  89.  
  90. (defconst tetris-space-char [?\040]
  91.   "Character vector used for a space")
  92.  
  93. (defconst tetris-block-char [?\040]
  94.   "Character vector for a full square in text mode")
  95.  
  96. (defconst tetris-emacs-block-char [?O]
  97.   "Character vector for a full square in text mode under Emacs")
  98.  
  99. (defconst tetris-border-char [?\+]
  100.   "Character vector for a border square in text mode")
  101.  
  102. (defconst tetris-buffer-width 30
  103.   "Width of used portion of buffer")
  104.  
  105. (defconst tetris-buffer-height 22
  106.   "Height of used portion of buffer")
  107.  
  108. (defconst tetris-width 10
  109.   "Width of playing area")
  110.  
  111. (defconst tetris-height 20
  112.   "Height of playing area")
  113.  
  114. (defconst tetris-top-left-x 3
  115.   "X position of top left of playing area")
  116.  
  117. (defconst tetris-top-left-y 1
  118.   "Y position of top left of playing area")
  119.  
  120. (defconst tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
  121.   "X position of next shape")
  122.  
  123. (defconst tetris-next-y tetris-top-left-y
  124.   "Y position of next shape")
  125.  
  126. (defconst tetris-score-x tetris-next-x
  127.   "X position of score")
  128.  
  129. (defconst tetris-score-y (+ tetris-next-y 6)
  130.   "Y position of score")
  131.  
  132. (defconst tetris-blank 0)
  133.  
  134. (defconst tetris-space ?\.)
  135.  
  136. (defconst tetris-border ?\*)
  137.  
  138. (defconst tetris-shapes
  139.   [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
  140.     [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
  141.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
  142.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
  143.  
  144.    [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
  145.     [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
  146.     [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
  147.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
  148.  
  149.    [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
  150.     [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
  151.     [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
  152.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
  153.  
  154.    [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
  155.     [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
  156.     [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
  157.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
  158.  
  159.    [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
  160.     [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
  161.     [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
  162.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
  163.  
  164.    [[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]]
  165.     [[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]]
  166.     [[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]]
  167.     [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
  168.  
  169.    [[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]]
  170.     [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
  171.     [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
  172.     [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]])
  173.  
  174. (defconst tetris-shape-dimensions
  175.   [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
  176.  
  177. (defconst tetris-text-colors
  178.   ["black" "blue" "white" "yellow"
  179.    "magenta" "cyan" "green" "red"]
  180.   "Vector of colors of the various shapes in text mode
  181. Element 0 is the background color")
  182.  
  183. (defconst tetris-colors
  184.   [[0 0 0] [0 0 1] [0.7 0 1] [1 1 0]
  185.    [1 0 1] [0 1 1] [0 1 0] [1 0 0]
  186.    [0.5 0.5 0.5]]
  187.   "Vector of colors of the various shapes
  188. Element 0 is the background color
  189. Element 8 is the border color")
  190.  
  191. (defconst tetris-xpm "\
  192. /* XPM */
  193. static char *noname[] = {
  194. /* width height ncolors chars_per_pixel */
  195. \"16 16 3 1\",
  196. /* colors */
  197. \"+ s col1\",
  198. \". s col2\",
  199. \"- s col3\",
  200. /* pixels */
  201. \"---------------+\",
  202. \"--------------++\",
  203. \"--............++\",
  204. \"--............++\",
  205. \"--............++\",
  206. \"--............++\",
  207. \"--............++\",
  208. \"--............++\",
  209. \"--............++\",
  210. \"--............++\",
  211. \"--............++\",
  212. \"--............++\",
  213. \"--............++\",
  214. \"--............++\",
  215. \"-+++++++++++++++\",
  216. \"++++++++++++++++\"
  217. };
  218. "
  219.   "XPM format image used for each square")
  220.  
  221. (defun tetris-default-update-speed-function (shapes rows)
  222.   (/ 20.0 (+ 50.0 rows)))
  223.  
  224. ;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  225.  
  226. (defvar tetris-faces (make-vector 256 nil))
  227.  
  228. (defvar tetris-buffer-start 1)
  229.  
  230. (defvar tetris-display-mode nil)
  231.  
  232. (defvar tetris-shape 0)
  233. (defvar tetris-rot 0)
  234. (defvar tetris-next-shape 0)
  235. (defvar tetris-n-shapes 0)
  236. (defvar tetris-n-rows 0)
  237. (defvar tetris-pos-x 0)
  238. (defvar tetris-pos-y 0)
  239.  
  240. (defvar tetris-timer nil)
  241.  
  242. (defvar tetris-display-table nil)
  243.  
  244. ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  245.  
  246. (defvar tetris-mode-map
  247.   (make-sparse-keymap 'tetris-mode-map))
  248.  
  249. (define-key tetris-mode-map "n"        'tetris-start-game)
  250. (define-key tetris-mode-map "q"        'tetris-end-game)
  251.  
  252. (define-key tetris-mode-map " "        'tetris-move-bottom)
  253. (define-key tetris-mode-map [left]    'tetris-move-left)
  254. (define-key tetris-mode-map [right]    'tetris-move-right)
  255. (define-key tetris-mode-map [up]    'tetris-rotate-prev)
  256. (define-key tetris-mode-map [down]    'tetris-rotate-next)
  257.  
  258. (defvar tetris-null-map
  259.   (make-sparse-keymap 'tetris-null-map))
  260.  
  261. (define-key tetris-null-map "n"        'tetris-start-game)
  262.  
  263. ;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  264.  
  265. (defun tetris-start-timer (period)
  266.   (setq tetris-timer
  267.     (if (featurep 'itimer)
  268.         (start-itimer
  269.          "Tetris"
  270.          'tetris-update-game period period
  271.          nil t (current-buffer))
  272.       (run-with-timer
  273.        period period
  274.        'tetris-update-game (current-buffer)))))
  275.  
  276. (defun tetris-set-timer (delay)
  277.   (if tetris-timer
  278.       (if (featurep 'itimer)
  279.       (set-itimer-restart tetris-timer delay)
  280.     (timer-set-time tetris-timer
  281.             (list (aref tetris-timer 1)
  282.                   (aref tetris-timer 2)
  283.                   (aref tetris-timer 3))
  284.             delay))))
  285.  
  286. (defun tetris-kill-timer ()
  287.   (if tetris-timer
  288.       (if (featurep 'itimer)
  289.           (delete-itimer tetris-timer)
  290.         (timer-set-time tetris-timer '(0 0 0) nil)))
  291.   (setq tetris-timer nil))
  292.  
  293. ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  294.  
  295. (defun tetris-color (col shade)
  296.   (let* ((vec (aref tetris-colors col))
  297.      (v (floor (* shade 255)))
  298.      (r (* v (aref vec 0)))
  299.      (g (* v (aref vec 1)))
  300.      (b (* v (aref vec 2))))
  301.     (format "#%02x%02x%02x" r g b)))
  302.  
  303. (defun tetris-set-font (face)
  304.   (if tetris-font
  305.       (condition-case nil
  306.       (set-face-font face tetris-font)
  307.     ('error nil))))
  308.  
  309. (defun tetris-setup-face (face color)
  310.   (set-face-foreground face color)
  311.   (set-face-background face color)
  312.   (tetris-set-font face)
  313.   (condition-case nil
  314.       (set-face-background-pixmap face [nothing])    ;; XEmacs
  315.     ('error nil))
  316.   (condition-case nil
  317.       (set-face-background-pixmap face nil)        ;; Emacs
  318.     ('error nil)))
  319.  
  320. (defun tetris-make-mono-tty-face ()
  321.   (let ((face (make-face 'tetris-mono-tty-face)))
  322.     (condition-case nil
  323.     (set-face-property face 'reverse t)
  324.       ('error nil))
  325.     face))
  326.  
  327. (defun tetris-make-color-tty-face (c)
  328.   (let* ((name (intern (format "tetris-color-tty-face-%d" c)))
  329.      (face (make-face name)))
  330.     (tetris-setup-face face (aref tetris-text-colors c))
  331.     face))
  332.  
  333. (defun tetris-make-x-border-face ()
  334.   (let ((face (make-face 'tetris-x-border-face)))
  335.     (tetris-set-font face)
  336.     face))
  337.  
  338. (defun tetris-make-mono-x-face ()
  339.   (let ((face (make-face 'tetris-mono-x-face))
  340.     (color (face-foreground 'default)))
  341.     (if (null color)
  342.     (setq color
  343.           (cdr-safe (assq 'foreground-color (frame-parameters)))))
  344.     (tetris-setup-face face color)
  345.     face))
  346.  
  347. (defun tetris-make-color-x-face (c)
  348.   (let* ((name (intern (format "tetris-color-x-face-%d" c)))
  349.      (face (make-face name)))
  350.     (tetris-setup-face face (tetris-color c 1.0))
  351.     face))
  352.  
  353. (defun tetris-make-mono-tty-faces ()
  354.   (let ((face (tetris-make-mono-tty-face)))
  355.     (loop for c from 0 to 255 do
  356.       (aset tetris-faces c
  357.         (cond
  358.          ((or (= c 0) (> c 7))
  359.           'default)
  360.          (t
  361.           face))))))
  362.  
  363. (defun tetris-make-color-tty-faces ()
  364.   (loop for c from 0 to 255 do
  365.     (aset tetris-faces c
  366.           (cond
  367.            ((> c 7)
  368.           'default)
  369.            (t
  370.         (tetris-make-color-tty-face c))))))
  371.  
  372. (defun tetris-make-mono-x-faces ()
  373.   (let ((face (tetris-make-mono-x-face))
  374.     (face2 (tetris-make-x-border-face)))
  375.     (loop for c from 0 to 255 do
  376.       (aset tetris-faces c
  377.         (cond
  378.          ((or (= c 0) (= c tetris-border))
  379.           face2)
  380.          ((> c 7)
  381.           'default)
  382.          (t
  383.           face))))))
  384.  
  385. (defun tetris-make-color-x-faces ()
  386.   (loop for c from 0 to 255 do
  387.     (aset tetris-faces c
  388.           (cond
  389.            ((= c tetris-border)
  390.         (tetris-make-x-border-face))
  391.            ((> c 7)
  392.         'default)
  393.            (t
  394.         (tetris-make-color-x-face c))))))
  395.  
  396. (defun tetris-make-glyph (index)
  397.   (make-glyph
  398.    (vector
  399.     'xpm
  400.     :data tetris-xpm
  401.     :color-symbols (list
  402.             (cons "col1" (tetris-color index 0.6))
  403.             (cons "col2" (tetris-color index 0.8))
  404.             (cons "col3" (tetris-color index 1.0))))))
  405.  
  406. (defun tetris-make-display-table ()
  407.   (setq tetris-display-table (make-display-table))
  408.   (aset tetris-display-table tetris-space tetris-space-char)
  409.   (case tetris-display-mode
  410.     ('glyph
  411.      (aset tetris-display-table tetris-border (tetris-make-glyph 8))
  412.      (aset tetris-display-table tetris-blank (tetris-make-glyph 0)))
  413.     (otherwise
  414.      (aset tetris-display-table tetris-border tetris-border-char)
  415.      (aset tetris-display-table tetris-blank tetris-space-char)))
  416.   (loop for i from 1 to 7 do
  417.     (aset tetris-display-table
  418.           (+ tetris-blank i)
  419.           (case tetris-display-mode
  420.         ('glyph
  421.          (tetris-make-glyph i))
  422.         ('emacs-tty
  423.          tetris-emacs-block-char)
  424.         (otherwise
  425.          tetris-block-char)))))
  426.  
  427. (defun tetris-color-display-p ()
  428.   (if (fboundp 'device-class)
  429.       (eq (device-class (selected-device)) 'color)
  430.     (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color)))
  431.  
  432. (defun tetris-display-type ()
  433.   (cond ((and tetris-use-glyphs (eq window-system 'x) (featurep 'xpm))
  434.      'glyph)
  435.     ((and tetris-use-color (eq window-system 'x) (tetris-color-display-p))
  436.      'color-x)
  437.     ((eq window-system 'x)
  438.      'mono-x)
  439.     ((and tetris-use-color (tetris-color-display-p))
  440.      'color-tty)
  441.     (t
  442.      (if (fboundp 'set-face-property)
  443.          'mono-tty
  444.        'emacs-tty))))
  445.  
  446. (defun tetris-initialize-display ()
  447.   (setq tetris-display-mode (tetris-display-type))
  448.   (tetris-make-display-table)
  449.   (case tetris-display-mode
  450.     ('mono-tty
  451.      (tetris-make-mono-tty-faces))
  452.     ('color-tty
  453.      (tetris-make-color-tty-faces))
  454.     ('mono-x
  455.      (tetris-make-mono-x-faces))
  456.     ('color-x
  457.      (tetris-make-color-x-faces))))
  458.  
  459. (defun tetris-set-display-table ()
  460.   (if (fboundp 'specifierp)
  461.       (add-spec-to-specifier current-display-table
  462.                  tetris-display-table
  463.                  (current-buffer)
  464.                  nil 'remove-locale)
  465.     (setq buffer-display-table tetris-display-table)))
  466.  
  467. (defun tetris-setup-default-face ()
  468.   (cond ((eq tetris-display-mode 'glyph)
  469.      (let* ((font-spec (face-property 'default 'font))
  470.         (name (font-name font-spec))
  471.         (glyph (aref tetris-display-table tetris-blank))
  472.         (height (glyph-height glyph)))
  473.        (while (and (> (font-height font-spec) height)
  474.                (setq name (x-find-smaller-font name)))
  475.          (add-spec-to-specifier font-spec name (current-buffer)))))))
  476.  
  477. (defun tetris-hide-cursor ()
  478.   (if (fboundp 'specifierp)
  479.       (set-specifier text-cursor-visible-p nil (current-buffer))))
  480.  
  481. (defun tetris-draw-border-p ()
  482.   (or (not (eq tetris-display-mode 'glyph))
  483.       tetris-draw-border-with-glyphs))
  484.  
  485. (defun tetris-set-color (c)
  486.   (unless (eq tetris-display-mode 'glyph)
  487.     (put-text-property
  488.      (1- (point)) (point) 'face (aref tetris-faces c))))
  489.  
  490. ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  491.  
  492. (defun tetris-get-tick-period ()
  493.   (if (boundp 'tetris-update-speed-function)
  494.       (let ((period (apply tetris-update-speed-function
  495.                tetris-n-shapes
  496.                tetris-n-rows nil)))
  497.     (and (numberp period) period))))
  498.  
  499. (defun tetris-cell-offset (x y)
  500.   (+ tetris-buffer-start
  501.      (* (1+ tetris-buffer-width) y)
  502.      x))
  503.  
  504. (defun tetris-get-cell (x y)
  505.   (char-after (tetris-cell-offset x y)))
  506.  
  507. (defun tetris-set-cell (x y c)
  508.   (save-excursion
  509.     (let ((buffer-read-only nil))
  510.       (goto-char (tetris-cell-offset x y))
  511.       (delete-char 1)
  512.       (insert-char c 1)
  513.       (tetris-set-color c))))
  514.  
  515. (defun tetris-get-shape-cell (x y)
  516.   (aref
  517.    (aref
  518.     (aref
  519.      (aref tetris-shapes tetris-shape)
  520.      y)
  521.     tetris-rot)
  522.    x))
  523.  
  524. (defun tetris-shape-width ()
  525.   (aref (aref tetris-shape-dimensions tetris-shape)
  526.     (% tetris-rot 2)))
  527.  
  528. (defun tetris-shape-height ()
  529.   (aref (aref tetris-shape-dimensions tetris-shape)
  530.     (- 1 (% tetris-rot 2))))
  531.  
  532. (defun tetris-draw-score ()
  533.   (let ((strings (vector
  534.           (format "Shapes: %05d" tetris-n-shapes)
  535.           (format "Rows:   %05d" tetris-n-rows))))
  536.     (loop for y from 0 to 1 do
  537.       (let* ((string (aref strings y))
  538.          (len (length string)))
  539.         (loop for x from 0 to (1- len) do
  540.           (tetris-set-cell
  541.            (+ tetris-score-x x)
  542.            (+ tetris-score-y y)
  543.            (aref string x)))))))
  544.  
  545. (defun tetris-update-score ()
  546.   (tetris-draw-score)
  547.   (let ((period (tetris-get-tick-period)))
  548.     (if period (tetris-set-timer period))))
  549.  
  550. (defun tetris-new-shape ()
  551.   (setq tetris-shape tetris-next-shape)
  552.   (setq tetris-rot 0)
  553.   (setq tetris-next-shape (random 7))
  554.   (setq tetris-pos-x (random (- tetris-width (tetris-shape-width))))
  555.   (setq tetris-pos-y 0)
  556.   (setq tetris-n-shapes (1+ tetris-n-shapes))
  557.   (tetris-draw-next-shape)
  558.   (tetris-update-score))
  559.  
  560. (defun tetris-draw-next-shape ()
  561.   (loop for y from 0 to 3 do
  562.     (loop for x from 0 to 3 do
  563.           (tetris-set-cell
  564.            (+ tetris-next-x x)
  565.            (+ tetris-next-y y)
  566.            (let ((tetris-shape tetris-next-shape)
  567.              (tetris-rot 0))
  568.          (tetris-get-shape-cell x y))))))
  569.  
  570. (defun tetris-draw-shape ()
  571.   (loop for y from 0 to (1- (tetris-shape-height)) do
  572.     (loop for x from 0 to (1- (tetris-shape-width)) do
  573.           (let ((c (tetris-get-shape-cell x y)))
  574.         (if (/= c tetris-blank)
  575.             (tetris-set-cell
  576.              (+ tetris-top-left-x tetris-pos-x x)
  577.              (+ tetris-top-left-y tetris-pos-y y)
  578.              c))))))
  579.  
  580. (defun tetris-erase-shape ()
  581.   (loop for y from 0 to (1- (tetris-shape-height)) do
  582.     (loop for x from 0 to (1- (tetris-shape-width)) do
  583.           (let ((c (tetris-get-shape-cell x y)))
  584.         (if (/= c tetris-blank)
  585.             (tetris-set-cell
  586.              (+ tetris-top-left-x tetris-pos-x x)
  587.              (+ tetris-top-left-y tetris-pos-y y)
  588.              tetris-blank))))))
  589.  
  590. (defun tetris-test-shape ()
  591.   (let ((hit nil))
  592.     (loop for y from 0 to (1- (tetris-shape-height)) do
  593.       (loop for x from 0 to (1- (tetris-shape-width)) do
  594.         (unless hit
  595.           (setq hit
  596.             (let ((c (tetris-get-shape-cell x y))
  597.                   (xx (+ tetris-pos-x x))
  598.                   (yy (+ tetris-pos-y y)))
  599.               (and (/= c tetris-blank)
  600.                    (or (>= xx tetris-width)
  601.                    (>= yy tetris-height)
  602.                    (/= (tetris-get-cell
  603.                     (+ tetris-top-left-x xx)
  604.                     (+ tetris-top-left-y yy))
  605.                        tetris-blank))))))))
  606.     hit))
  607.  
  608. (defun tetris-full-row (y)
  609.   (let ((full t))
  610.     (loop for x from 0 to (1- tetris-width) do
  611.       (if (= (tetris-get-cell
  612.           (+ tetris-top-left-x x)
  613.           (+ tetris-top-left-y y))
  614.          tetris-blank)
  615.           (setq full nil)))
  616.     full))
  617.  
  618. (defun tetris-shift-row (y)
  619.   (loop for x from 0 to (1- tetris-width) do
  620.     (let ((c (tetris-get-cell
  621.          (+ tetris-top-left-x x)
  622.          (+ tetris-top-left-y y -1))))
  623.       (tetris-set-cell
  624.        (+ tetris-top-left-x x)
  625.        (+ tetris-top-left-y y)
  626.        c))))
  627.  
  628. (defun tetris-shift-down ()
  629.   (loop for y0 from 0 to (1- tetris-height) do
  630.     (if (tetris-full-row y0)
  631.         (progn
  632.           (setq tetris-n-rows (1+ tetris-n-rows))
  633.           (tetris-update-score)
  634.           (loop for y from y0 downto 1 do
  635.             (tetris-shift-row y))))))
  636.  
  637. (defun tetris-init-buffer ()
  638.   (let ((line (concat
  639.            (make-string tetris-buffer-width tetris-space)
  640.            "\n"))
  641.     (buffer-read-only nil))
  642.     (erase-buffer)
  643.     (setq tetris-buffer-start (point))
  644.     (dotimes (i tetris-buffer-height)
  645.       (insert-string line))
  646.     (goto-char (point-min))
  647.     (if (tetris-draw-border-p)
  648.       (loop for y from -1 to tetris-height do
  649.         (loop for x from -1 to tetris-width do
  650.           (tetris-set-cell
  651.            (+ tetris-top-left-x x)
  652.            (+ tetris-top-left-y y)
  653.            tetris-border))))
  654.     (loop for y from 0 to (1- tetris-height) do
  655.       (loop for x from 0 to (1- tetris-width) do
  656.         (tetris-set-cell
  657.          (+ tetris-top-left-x x)
  658.          (+ tetris-top-left-y y)
  659.          tetris-blank)))
  660.     (if (tetris-draw-border-p)
  661.       (loop for y from -1 to 4 do
  662.         (loop for x from -1 to 4 do
  663.           (tetris-set-cell
  664.            (+ tetris-next-x x)
  665.            (+ tetris-next-y y)
  666.            tetris-border))))))
  667.  
  668. (defun tetris-reset-game ()
  669.   (tetris-kill-timer)
  670.   (tetris-init-buffer)
  671.   (setq tetris-next-shape (random 7))
  672.   (setq tetris-shape        0
  673.     tetris-rot        0
  674.     tetris-n-shapes        0
  675.     tetris-n-rows        0
  676.     tetris-pos-x        0
  677.     tetris-pos-y        0)
  678.   (tetris-new-shape)
  679.   (tetris-draw-shape))
  680.  
  681. (defun tetris-shape-done ()
  682.   (tetris-shift-down)
  683.   (tetris-new-shape)
  684.   (if (tetris-test-shape)
  685.       (progn
  686.     (tetris-end-game))
  687.     (tetris-draw-shape)))
  688.  
  689. (defun tetris-update-game (tetris-buffer)
  690.   "Called on each clock tick.
  691. Drops the shape one square, testing for collision."
  692.   (if (eq (current-buffer) tetris-buffer)
  693.       (let (hit)
  694.     (tetris-erase-shape)
  695.     (setq tetris-pos-y (1+ tetris-pos-y))
  696.     (setq hit (tetris-test-shape))
  697.     (if hit
  698.         (setq tetris-pos-y (1- tetris-pos-y)))
  699.     (tetris-draw-shape)
  700.     (if hit
  701.         (tetris-shape-done)))))
  702.  
  703. (defun tetris-move-bottom ()
  704.   "Drops the shape to the bottom of the playing area"
  705.   (interactive)
  706.   (let ((hit nil))
  707.     (tetris-erase-shape)
  708.     (while (not hit)
  709.       (setq tetris-pos-y (1+ tetris-pos-y))
  710.       (setq hit (tetris-test-shape)))
  711.     (setq tetris-pos-y (1- tetris-pos-y))
  712.     (tetris-draw-shape)
  713.     (tetris-shape-done)))
  714.  
  715. (defun tetris-move-left ()
  716.   "Moves the shape one square to the left"
  717.   (interactive)
  718.   (unless (= tetris-pos-x 0)
  719.     (tetris-erase-shape)
  720.     (setq tetris-pos-x (1- tetris-pos-x))
  721.     (if (tetris-test-shape)
  722.     (setq tetris-pos-x (1+ tetris-pos-x)))
  723.     (tetris-draw-shape)))
  724.  
  725. (defun tetris-move-right ()
  726.   "Moves the shape one square to the right"
  727.   (interactive)
  728.   (unless (= (+ tetris-pos-x (tetris-shape-width))
  729.          tetris-width)
  730.     (tetris-erase-shape)
  731.     (setq tetris-pos-x (1+ tetris-pos-x))
  732.     (if (tetris-test-shape)
  733.     (setq tetris-pos-x (1- tetris-pos-x)))
  734.     (tetris-draw-shape)))
  735.  
  736. (defun tetris-rotate-prev ()
  737.   "Rotates the shape clockwise"
  738.   (interactive)
  739.   (tetris-erase-shape)
  740.   (setq tetris-rot (% (+ 1 tetris-rot) 4))
  741.   (if (tetris-test-shape)
  742.       (setq tetris-rot (% (+ 3 tetris-rot) 4)))
  743.   (tetris-draw-shape))
  744.  
  745. (defun tetris-rotate-next ()
  746.   "Rotates the shape anticlockwise"
  747.   (interactive)
  748.   (tetris-erase-shape)
  749.   (setq tetris-rot (% (+ 3 tetris-rot) 4))
  750.   (if (tetris-test-shape)
  751.       (setq tetris-rot (% (+ 1 tetris-rot) 4)))
  752.   (tetris-draw-shape))
  753.  
  754. (defun tetris-end-game ()
  755.   "Terminates the current game"
  756.   (interactive)
  757.   (tetris-kill-timer)
  758.   (use-local-map tetris-null-map))
  759.  
  760. (defun tetris-start-game ()
  761.   "Starts a new game of Tetris"
  762.   (interactive)
  763.   (tetris-reset-game)
  764.   (use-local-map tetris-mode-map)
  765.   (let ((period (or (tetris-get-tick-period)
  766.             tetris-default-tick-period)))
  767.     (tetris-start-timer period)))
  768.  
  769. (put 'tetris-mode 'mode-class 'special)
  770.  
  771. (defun tetris-mode ()
  772.   "A mode for playing Tetris.
  773.  
  774. tetris-mode keybindings:
  775.    \\{tetris-mode-map}
  776. "
  777.   (kill-all-local-variables)
  778.  
  779.   (make-local-hook 'kill-buffer-hook)
  780.   (add-hook 'kill-buffer-hook 'tetris-end-game nil t)
  781.  
  782.   (make-local-variable 'tetris-display-mode)
  783.   (make-local-variable 'tetris-display-table)
  784.   (make-local-variable 'tetris-faces)
  785.   (make-local-variable 'tetris-timer)
  786.   (make-local-variable 'tetris-buffer-start)
  787.   (make-local-variable 'tetris-shape)
  788.   (make-local-variable 'tetris-rot)
  789.   (make-local-variable 'tetris-next-shape)
  790.   (make-local-variable 'tetris-n-shapes)
  791.   (make-local-variable 'tetris-n-rows)
  792.   (make-local-variable 'tetris-pos-x)
  793.   (make-local-variable 'tetris-pos-y)
  794.  
  795.   (use-local-map tetris-null-map)
  796.  
  797.   (setq buffer-read-only t)
  798.   (setq truncate-lines 't)
  799.   (setq major-mode 'tetris-mode)
  800.   (setq mode-name "Tetris")
  801.  
  802.   (buffer-disable-undo (current-buffer))
  803.  
  804.   (tetris-initialize-display)
  805.   (tetris-setup-default-face)
  806.   (tetris-set-display-table)
  807.   (tetris-hide-cursor)
  808.  
  809.   (run-hooks 'tetris-mode-hook))
  810.  
  811. ;;;###autoload
  812. (defun tetris ()
  813.   "Tetris
  814.  
  815. Shapes drop from the top of the screen, and the user has to move and
  816. rotate the shape to fit in with those at the bottom of the screen so
  817. as to form complete rows.
  818.  
  819. tetris-mode keybindings:
  820.    \\<tetris-mode-map>
  821. \\[tetris-start-game]    Starts a new game of Tetris
  822. \\[tetris-end-game]    Terminates the current game
  823. \\[tetris-move-left]    Moves the shape one square to the left
  824. \\[tetris-move-right]    Moves the shape one square to the right
  825. \\[tetris-rotate-prev]    Rotates the shape clockwise
  826. \\[tetris-rotate-next]    Rotates the shape anticlockwise
  827. \\[tetris-move-bottom]    Drops the shape to the bottom of the playing area
  828.  
  829. "
  830.   (interactive)
  831.  
  832.   (switch-to-buffer tetris-buffer-name)
  833.   (tetris-kill-timer)
  834.   (tetris-mode)
  835.   (tetris-start-game))
  836.  
  837. (provide 'tetris)
  838.  
  839. ;;; tetris.el ends here
  840.  
  841.